home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / forthcmp.zip / DISPLAY2.4TH < prev    next >
Text File  |  1992-03-30  |  4KB  |  116 lines
  1. \ FORTH COMPILER  DISPLAY LIBRARY                 18:35 11/30/91
  2.  
  3. 0 #IF
  4. COPYRIGHT 1985 (C) BY THOMAS ALMY.  ALL RIGHTS RESERVED
  5. Permission is granted to registered users of ForthCMP to sell or distribute
  6. computer programs incorporating the compiled contents of this file.
  7.  
  8. Fast Terminal output for IBM pc or compatibles.
  9. Works with monochrome or color monitors, 80 column text only!
  10. EMIT generates all 256 characters -- no control functions.
  11.  
  12. Include file DISPLAY1 at start of program.
  13. Include this file before FORTHLIB
  14. Define constant VID-DELAY non-zero for vertical retrace blanking
  15. Execute SETUP-VID at program start, and UNSETUP-VID at finish
  16.  
  17. This library defines EMIT, TYPE, CS:TYPE, CLS, GOTOXY, FOREGROUND,
  18. BACKGROUND, INTENSITY, -INTENSITY, BLINK, -BLINK, as in
  19. PC/Forth. DO NOT use CONSOLE PRINTER and/or MESSAGES!
  20.  
  21.  
  22. #THEN
  23.  
  24. 10 HEX
  25. 1 0 IN/OUT
  26. : setcursor ( DISPL -- )   DUP cursor !  crtstart +
  27.    2/ DUP 0F crtport @ PC! crtport @ 1+ PC!
  28.    >< 0E crtport @ PC! crtport @ 1+ PC! ;
  29. 2 0 IN/OUT
  30. : GOTOXY ( X Y -- ) c/l * + 2* setcursor ;
  31. FIND VID-DELAY #IF DROP #ELSE 0 CONSTANT VID-DELAY #THEN
  32. 0 0 IN/OUT
  33. : SETUP-VID
  34.  40 49 C@L 7 = IF 3B4 crtport ! B000 vidseg ! ELSE \ MONOCHROME
  35.      40 84 C@L ?DUP IF 1+ EQU l/s THEN THEN
  36.      c/l l/s * EQU c/s   c/l l/s 1- * 2* EQU c/sm1
  37.  40 4E @L EQU crtstart
  38.  40 50 C@L 40 51 C@L GOTOXY
  39.  vidseg @  c/sm1 1+ crtstart + C@L style ! ;
  40. 0 0 IN/OUT
  41. CODE UNSETUP-VID  cursor [] AX MOV  c/l # BX MOV DX DX XOR
  42.   AX 1 SAR  BX IDIV
  43.   AL DH MOV  2 # AH MOV BH BH XOR  10 INT  RET END-CODE
  44. CODE scrmove  ( source dest wordCount -- )
  45.     BX POP CX POP DI POP SI POP
  46.     ' crtstart [] SI ADD
  47.     ' crtstart [] DI ADD
  48.     LOOP IF,  DS PUSHSEG
  49. VID-DELAY #IF  B800 # vidseg [] CMP  =0 IF,  3DA # DX MOV
  50.    BEGIN,  BYTE [DX] IN  8 # AL TEST  =0 ~ UNTIL,
  51.       DX DEC  DX DEC  21 # AL MOV  BYTE [DX] OUT  THEN, #THEN
  52.               vidseg [] AX MOV   AX DS >SEG  AX ES >SEG
  53.               REPZ MOVS  DS POPSEG
  54. VID-DELAY #IF  B800 # vidseg [] CMP  =0 IF,  3D8 # DX MOV
  55.       29 # AL MOV  BYTE [DX] OUT  THEN, #THEN
  56.       THEN, BX JMPI END-CODE
  57. 2 0 IN/OUT
  58. CODE scrfill ( source wordCount -- )
  59.     vidseg [] ES >SEG
  60.     BX PUSH  ' crtstart [] BX ADD
  61.     20 # BYTE ES: [BX] MOV
  62.     style [] CL MOV  CL ES: 1 +[BX] MOV
  63.     BX POP
  64.     BX PUSH  BX INC BX INC BX PUSH  AX DEC AX PUSH
  65.     CALL' scrmove   RET  END-CODE
  66. 0 0 IN/OUT
  67. : scrollup  c/l 2*  0  c/sm1 2/ scrmove
  68.       c/sm1 c/l  scrfill
  69.       c/sm1 cursor ! ;
  70. U: CLS  0  c/s  scrfill  0 setcursor ;
  71. U: FOREGROUND 0F AND style @ F0 AND OR style ! ;
  72. U: BACKGROUND 7 AND 4 << style @ 0F AND OR style ! ;
  73. U: BLINK 80 style CSET ;
  74. U: -BLINK 80 style CRESET ;
  75. U: INTENSITY  8 style CSET ;
  76. U: -INTENSITY 8 style CRESET ;
  77.  
  78. : EMIT  cursor @  c/s 2* >= IF scrollup THEN
  79.         vidseg @ cursor @ crtstart + C!L
  80.         style @ vidseg @ cursor @ 1+ crtstart + C!L
  81.         cursor @ 2+ setcursor ;
  82. : CR   cursor @  c/l 2*  U/  1+  c/l 2*  *
  83.     DUP c/s 2* = IF DROP scrollup  cursor @ THEN
  84.     setcursor ;
  85.  
  86. VID-DELAY 0= #IF
  87. 2 1 IN/OUT
  88. CODE (type) ( AX has count, BX has string )
  89.     cursor [] DI MOV  AX CX MOV  style [] AH MOV  BX SI MOV
  90.     ' crtstart [] DI ADD
  91.     vidseg [] ES >SEG  LOOP IF, BEGIN,  BYTE LODS
  92.     STOS  LOOP ~ UNTIL,  THEN,
  93.     DI AX MOV   ' crtstart [] AX SUB
  94.     RET  END-CODE
  95. SEPDSEG? NOT #IF CODE CS:TYPE END-CODE #THEN
  96. : TYPE c/s cursor @ - OVER 2* < IF ( too big )
  97.        0 ?DO COUNT EMIT LOOP DROP
  98.        ELSE (type) setcursor THEN ;
  99. #THEN
  100.  
  101. VID-DELAY 0= #IF
  102. SEPDSEG? #IF
  103. 2 1 IN/OUT
  104. CODE (cs:type) ( AX has count, BX has string )
  105.     cursor [] DI MOV  AX CX MOV  style [] AH MOV  BX SI MOV
  106.     ' crtstart [] DI ADD
  107.     vidseg [] ES >SEG  LOOP IF, BEGIN, CS: BYTE LODS  STOS
  108.        LOOP ~ UNTIL,  THEN,
  109.     DI AX MOV   ' crtstart [] AX SUB
  110.     RET  END-CODE
  111. : CS:TYPE c/s 2* cursor @ - OVER 2* < IF ( too big )
  112.        0 ?DO CS: COUNT EMIT LOOP DROP
  113.        ELSE (cs:type) setcursor THEN ;
  114. #THEN   #THEN
  115. 0A = #IF DECIMAL #THEN
  116.